home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Basic / Visual Basic.60 / COMMON / TOOLS / VB / UNSUPPRT / SSAVER / SSAVER.BAS < prev    next >
Encoding:
BASIC Source File  |  1997-01-16  |  18.3 KB  |  351 lines
  1. Attribute VB_Name = "mSSaver"
  2. Option Explicit
  3.  
  4. Public DisplayHwnd As Long                      ' Hwnd of display form
  5. Public DispRec As RECT                          ' Rectangle values of display form
  6. Public PrevWndProc As Long                      ' Previous window proc (used in subclassing)
  7. Public RunMode As Long                          ' Screen saver running mode (run, preview, setup)
  8. Public DeskBmp As BITMAP                        ' Bitmap copy of the desktop
  9. Public DeskDC As Long                           ' Desktop device context handle
  10.  
  11. '-----------------------------------------------------------------
  12. Sub Main()
  13. '-----------------------------------------------------------------
  14.     Dim rc As Long                              ' function return code
  15.     Dim cmd As String                           ' command line arguments
  16.     Dim Style As Long                           ' window style of display form
  17. '-----------------------------------------------------------------
  18.     If App.PrevInstance Then End                ' Already have one instance running, end program!
  19. '''   Set gSpriteCollection = New Collection      ' Create new sprite collection
  20.     
  21.     cmd = LCase$(Trim$(Command$))               ' copy command line parameters in lowercase...
  22.     
  23.     Select Case Mid$(cmd, 1, 2)                 ' Parse 1st 2 chars from cmd line
  24.     '------------------------------------------------------------
  25.     Case "", "/s"   '[Normal Run Mode]            Run as Screen Saver on desktop.
  26.     '------------------------------------------------------------
  27.         RunMode = RM_NORMAL                     ' Store screen saver's run mode
  28.         
  29.         GetWindowRect GetDesktopWindow(), DispRec ' Get DeskTop Rectangle dimentions
  30.         
  31.         Load frmSSaver                          ' Load Screen saver
  32. #If DebugOn Then                                ' Do this only when debugging
  33.         frmSSaver.Show
  34. #Else                                           ' Do this only when NOT debugging
  35.         SetWindowPos frmSSaver.hwnd, _
  36.                      HWND_TOPMOST, 0&, 0&, DispRec.Right, DispRec.Bottom, _
  37.                      SWP_SHOWWINDOW             ' Size window and make top most
  38. #End If
  39.     '------------------------------------------------------------
  40.      Case "/p"      '[Win 95 & NT 4 Preview Mode] Run inside of the Screen Saver Config Viewer.
  41.     '------------------------------------------------------------
  42.     '- Run the screen saver in the windows preview dialog, YES in VB!
  43.     '------------------------------------------------------------
  44.         RunMode = RM_PREVIEW                    ' Store screen saver's run mode...
  45.         
  46.         DisplayHwnd = GetHwndFromCmd(cmd)       ' ** Get HWND of Preview  DeskTop
  47.         GetClientRect DisplayHwnd, DispRec      ' Get Display Rectangle dimentions
  48.         
  49.         Load frmSSaver                          ' Load Screen saver form
  50.         frmSSaver.Caption = "Preview"           ' Consistant with Win 95 screen savers(what the heck)
  51.         
  52.         Style = GetWindowLong(frmSSaver.hwnd, GWL_STYLE) ' ** Get current window style
  53.         Style = Style Or WS_CHILD                        ' ** Append "WS_CHILD" style to the hWnd window style
  54.         SetWindowLong frmSSaver.hwnd, GWL_STYLE, Style   ' ** Add new style to window
  55.         
  56.         SetParent frmSSaver.hwnd, DisplayHwnd   ' ** Set preview window as parent window
  57.         SetWindowLong frmSSaver.hwnd, GWL_HWNDPARENT, DisplayHwnd ' ** Save the hWnd Parent in hWnd's window struct.
  58.         
  59.         ' ** Show screensaver in the preview window...
  60.         SetWindowPos frmSSaver.hwnd, _
  61.                      HWND_TOP, 0&, 0&, DispRec.Right, DispRec.Bottom, _
  62.                      SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_SHOWWINDOW
  63.     '------------------------------------------------------------
  64.     ' lines prefixed with ** are necessary for the preview dialog to work correctly.
  65.     '------------------------------------------------------------
  66.     Case "/c"       '[ScreenSaver Configuration Mode] Run Screen Saver Settings Dialog.
  67.     '------------------------------------------------------------
  68.         Load frmSSetup                          ' Load screensaver setup dialog
  69.         frmSSetup.Show vbModeless               ' Show setup dialog
  70.     '------------------------------------------------------------
  71.     Case Else
  72.     '------------------------------------------------------------
  73. #If DebugOn Then                                ' Do this only when debugging
  74.         MsgBox "Unknown Command Line Param: [" & Command$ & "]" ' Debug/display unknown param...
  75. #End If
  76.     End Select
  77. '-----------------------------------------------------------------
  78. End Sub
  79. '-----------------------------------------------------------------
  80.  
  81. '------------------------------------------------------------
  82. Public Function SubWndProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  83. '------------------------------------------------------------
  84. '- Subclassing not implemented but reservered for furture use...
  85. '------------------------------------------------------------
  86. '    Select Case MSG
  87. '    Case WM_PAINT
  88. '        SubWndProc = CallWindowProc(PrevWndProc, hwnd, MSG, wParam, lParam)
  89. '        PaintDeskDC DeskDC, DeskBmp, hwnd
  90. '        Exit Function
  91. '    End Select
  92.  
  93. '    SubWndProc = CallWindowProc(PrevWndProc, hwnd, MSG, wParam, lParam)
  94. '------------------------------------------------------------
  95. End Function
  96. '------------------------------------------------------------
  97.  
  98. '-----------------------------------------------------------------
  99. Private Function GetHwndFromCmd(cmd As String) As Long
  100. '-----------------------------------------------------------------
  101.     Dim Str As String                           ' substring variable
  102.     Dim lenStr As Long                          ' length of substring
  103.     Dim Idx As Long                             ' Index variable
  104. '-----------------------------------------------------------------
  105.     Str = Trim$(cmd)                            ' copy command line
  106.     lenStr = Len(Str)                           ' get size of string
  107.     
  108.     For Idx = lenStr To 1 Step -1               ' for each char in string
  109.         Str = Right$(Str, Idx)                  ' chop off the rightmost char
  110.         If IsNumeric(Str) Then                  ' if substring is numeric then value is an hWnd
  111.             GetHwndFromCmd = Val(Str)           ' return hWnd value
  112.             Exit For                            ' exit for loop
  113.         End If
  114.     Next
  115. '-----------------------------------------------------------------
  116. End Function
  117. '-----------------------------------------------------------------
  118.  
  119. '-----------------------------------------------------------------
  120. Public Sub AboutBox(hwnd As Long)
  121. '-----------------------------------------------------------------
  122.     ' Show help about dialog...
  123.     ShellAbout hwnd, "Visual Basic 5.0 - Screen Saver...", _
  124.                vbCrLf & "Building Applications in Visual Basic 5.0", 0
  125. '-----------------------------------------------------------------
  126. End Sub
  127. '-----------------------------------------------------------------
  128.  
  129. '-----------------------------------------------------------------
  130. Private Sub AssertRC(bool As Boolean, rc As Long, fcnName As String)
  131. '-----------------------------------------------------------------
  132. #If DebugOn Then
  133.     If Not bool Then
  134.         MsgBox "Assertion Failed::" & vbCrLf & _
  135.                "       In Module:: " & fcnName & vbCrLf & _
  136.                "     Return Code:: " & CStr(rc), vbCritical
  137.     End If
  138. #End If
  139. '-----------------------------------------------------------------
  140. End Sub
  141. '-----------------------------------------------------------------
  142.  
  143. '------------------------------------------------------------
  144. Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
  145. '------------------------------------------------------------
  146.     Dim i As Long                                           ' Loop Counter
  147.     Dim rc As Long                                          ' Return Code
  148.     Dim hKey As Long                                        ' Handle To An Open Registry Key
  149.     Dim hDepth As Long                                      '
  150.     Dim KeyValType As Long                                  ' Data Type Of A Registry Key
  151.     Dim tmpVal As String                                    ' Tempory Storage For A Registry Key Value
  152.     Dim KeyValSize As Long                                  ' Size Of Registry Key Variable
  153.     '------------------------------------------------------------
  154.     ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
  155.     '------------------------------------------------------------
  156.     rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
  157.     
  158.     If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Error...
  159.     
  160.     tmpVal = String$(1024, 0)                               ' Allocate Variable Space
  161.     KeyValSize = 1024                                       ' Mark Variable Size
  162.     
  163.     '------------------------------------------------------------
  164.     ' Retrieve Registry Key Value...
  165.     '------------------------------------------------------------
  166.     rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
  167.                          KeyValType, tmpVal, KeyValSize)    ' Get/Create Key Value
  168.                         
  169.     If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Errors
  170.     
  171.     If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then           ' Win95 Adds Null Terminated String...
  172.         tmpVal = Left(tmpVal, KeyValSize - 1)               ' Null Found, Extract From String
  173.     Else                                                    ' WinNT Does NOT Null Terminate String...
  174.         tmpVal = Left(tmpVal, KeyValSize)                   ' Null Not Found, Extract String Only
  175.     End If
  176.     '------------------------------------------------------------
  177.     ' Determine Key Value Type For Conversion...
  178.     '------------------------------------------------------------
  179.     Select Case KeyValType                                  ' Search Data Types...
  180.     Case REG_SZ                                             ' String Registry Key Data Type
  181.         KeyVal = tmpVal                                     ' Copy String Value
  182.     Case REG_DWORD                                          ' Double Word Registry Key Data Type
  183.         For i = Len(tmpVal) To 1 Step -1                    ' Convert Each Bit
  184.             KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' Build Value Char. By Char.
  185.         Next
  186.         KeyVal = Format$("&h" + KeyVal)                     ' Convert Double Word To String
  187.     End Select
  188.     
  189.     GetKeyValue = True                                      ' Return Success
  190.     rc = RegCloseKey(hKey)                                  ' Close Registry Key
  191.     Exit Function                                           ' Exit
  192. '------------------------------------------------------------
  193. GetKeyError:    ' Cleanup After An Error Has Occured...
  194. '------------------------------------------------------------
  195.     KeyVal = ""                                             ' Set Return Val To Empty String
  196.     GetKeyValue = False                                     ' Return Failure
  197.     rc = RegCloseKey(hKey)                                  ' Close Registry Key
  198. '------------------------------------------------------------
  199. End Function
  200. '------------------------------------------------------------
  201.  
  202. '------------------------------------------------------------
  203. Public Function UpdateKey(KeyRoot As Long, KeyName As String, SubKeyName As String, SubKeyValue As String) As Boolean
  204. '------------------------------------------------------------
  205.     Dim rc As Long                                      ' Return Code
  206.     Dim hKey As Long                                    ' Handle To A Registry Key
  207.     Dim hDepth As Long                                  '
  208.     Dim lpAttr As SECURITY_ATTRIBUTES                   ' Registry Security Type
  209. '------------------------------------------------------------
  210.     lpAttr.nLength = 50                                 ' Set Security Attributes To Defaults...
  211.     lpAttr.lpSecurityDescriptor = 0                     ' ...
  212.     lpAttr.bInheritHandle = True                        ' ...
  213.  
  214.     '------------------------------------------------------------
  215.     '- Create/Open Registry Key...
  216.     '------------------------------------------------------------
  217.     rc = RegCreateKeyEx(KeyRoot, KeyName, _
  218.                         0, REG_SZ, _
  219.                         REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, _
  220.                         hKey, hDepth)                   ' Create/Open //KeyRoot//KeyName
  221.     
  222.     If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError   ' Handle Errors...
  223.     
  224.     '------------------------------------------------------------
  225.     '- Create/Modify Key Value...
  226.     '------------------------------------------------------------
  227.     If (SubKeyValue = "") Then SubKeyValue = " "        ' A Space Is Needed For RegSetValueEx() To Work...
  228.     
  229.     rc = RegSetValueEx(hKey, SubKeyName, _
  230.                        0, REG_SZ, _
  231.                        SubKeyValue, Len(SubKeyValue))   ' Create/Modify Key Value
  232.  
  233.     If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError   ' Handle Error
  234.     '------------------------------------------------------------
  235.     '- Close Registry Key...
  236.     '------------------------------------------------------------
  237.     rc = RegCloseKey(hKey)                              ' Close Key
  238.     
  239.     UpdateKey = True                                    ' Return Success
  240.     Exit Function                                       ' Exit
  241. '------------------------------------------------------------
  242. CreateKeyError:
  243. '------------------------------------------------------------
  244.     UpdateKey = False                                   ' Set Error Return Code
  245.     rc = RegCloseKey(hKey)                              ' Attempt To Close Key
  246. '------------------------------------------------------------
  247. End Function
  248. '------------------------------------------------------------
  249.  
  250. '------------------------------------------------------------
  251. Public Sub SaveSettings()
  252. '------------------------------------------------------------
  253.     Dim RegVal As String                                ' String value of registry key
  254.     Dim lRegVal As Long                                 ' long value of registry key
  255. '------------------------------------------------------------
  256.     ' Save Sprite Count Value
  257.     RegVal = CStr(gSpriteCount)
  258.     Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITECOUNT, RegVal)
  259.     
  260.     ' Save Tracers on Value
  261.     RegVal = sFALSE
  262.     If gTracers Then RegVal = sTRUE
  263.     Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_TRACERSON, RegVal)
  264.     
  265.     ' Save Refresh Rate Value
  266.     RegVal = CStr(gRefreshRate)
  267.     Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_REFRESHRATE, RegVal)
  268.     
  269.     ' Save Rate Random Value
  270.     RegVal = sFALSE
  271.     If gRefreshRND Then RegVal = sTRUE
  272.     Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_RATERANDOM, RegVal)
  273.     
  274.     ' Save Sprite Size Value
  275.     RegVal = CStr(gSpriteSize)
  276.     Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITESIZE, RegVal)
  277.     
  278.     ' Save Size Random Value
  279.     RegVal = sFALSE
  280.     If gSizeRND Then RegVal = sTRUE
  281.     Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SIZERANDOM, RegVal)
  282.     
  283.     ' Save Sprite Speed Value
  284.     RegVal = CStr(gSpriteSpeed)
  285.     Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITESPEED, RegVal)
  286.     
  287.     ' Save Speed Random Value
  288.     RegVal = sFALSE
  289.     If gSpeedRND Then RegVal = sTRUE
  290.     Call UpdateKey(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPEEDRANDOM, RegVal)
  291. '------------------------------------------------------------
  292. End Sub
  293. '------------------------------------------------------------
  294.  
  295. '------------------------------------------------------------
  296. Public Sub LoadSettings()
  297. '------------------------------------------------------------
  298.     Dim RegVal As String
  299.     Dim iRegVal As Long
  300. '------------------------------------------------------------
  301.     ' Get Sprite Count Value
  302.     RegVal = ""
  303.     Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITECOUNT, RegVal)
  304.     gSpriteCount = Val(RegVal)
  305.     If (gSpriteCount < MIN_SPRITECOUNT) Then gSpriteCount = DEF_SPRITECOUNT ' Default value.
  306.     If (gSpriteCount > MAX_SPRITECOUNT) Then gSpriteCount = MAX_SPRITECOUNT
  307.     
  308.     ' Get Tracers on Value
  309.     RegVal = ""
  310.     Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_TRACERSON, RegVal)
  311.     gTracers = (RegVal = sTRUE)
  312.  
  313.     ' Get Refresh Rate Value
  314.     RegVal = ""
  315.     Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_REFRESHRATE, RegVal)
  316.     gRefreshRate = Val(RegVal)
  317.     If (gRefreshRate < MIN_REFRESHRATE) Then gRefreshRate = MAX_REFRESHRATE ' Default value ...fast
  318.     If (gRefreshRate > MAX_REFRESHRATE) Then gRefreshRate = MAX_REFRESHRATE
  319.     
  320.     ' Get Rate Random Value
  321.     RegVal = ""
  322.     Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_RATERANDOM, RegVal)
  323.     gRefreshRND = (RegVal = sTRUE)
  324.        
  325.     ' Get Sprite Size Value
  326.     RegVal = ""
  327.     Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITESIZE, RegVal)
  328.     gSpriteSize = Val(RegVal)
  329.     If (gSpriteSize < MIN_SPRITESIZE) Then gSpriteSize = MIN_SPRITESIZE
  330.     If (gSpriteSize > MAX_SPRITESIZE) Then gSpriteSize = MAX_SPRITESIZE
  331.     
  332.     ' Get Size Random Value
  333.     RegVal = ""
  334.     Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SIZERANDOM, RegVal)
  335.     gSizeRND = (RegVal = sTRUE) Or (RegVal = "")    ' Default to TRUE
  336.     
  337.     ' Get Sprite Speed Value
  338.     RegVal = ""
  339.     Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPRITESPEED, RegVal)
  340.     gSpriteSpeed = Val(RegVal)
  341.     If (gSpriteSpeed < MIN_SPRITESPEED) Then gSpriteSpeed = MIN_SPRITESPEED
  342.     If (gSpriteSpeed > MAX_SPRITESPEED) Then gSpriteSpeed = MAX_SPRITESPEED
  343.     
  344.     ' Get Speed Random Value
  345.     RegVal = ""
  346.     Call GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEY_APPROOT, gREGVAL_SPEEDRANDOM, RegVal)
  347.     gSpeedRND = (RegVal = sTRUE)
  348. '------------------------------------------------------------
  349. End Sub
  350. '------------------------------------------------------------
  351.